CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/intrfc70.zip/NAMELIST.PAS

Pascal/Delphi Source File | 1994-03-16 | 41KB | 1,399 lines

unit namelist;
{$I SWITCHES.INC}
{ These are the routines that print the name definitions }

interface

uses
  dump,util,globals,loader,head,nametype;

var
  last_kind : byte;
  in_function : boolean;
  NowEnum: type_def_ptr;

procedure print_name_list(obj_list:list_ptr);
procedure print_obj(obj:obj_ptr);
procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
function find_type_or_proc(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
function find_proc_with_entry(in_unit:unit_list_ptr;entry:word):string;
procedure write_var_type(type_unit,type_def_ofs:word);
procedure write_var_info(var name:string; info:var_info_ptr);
procedure write_enum_const(type_obj:type_def_ptr;val:longint);
procedure write_const_type(var Val;type_unit,type_def_ofs:word;buffer:pointer);
procedure write_args(arg:arg_ptr; num_args:word);
procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
procedure write_proc_info(var name:string; info:func_info_ptr);
procedure write_const_info(var name:string; info:const_info_ptr);
procedure write_system_type(var name:string; kind:byte; info:system_info_ptr);
procedure write_general(kind:byte; title,name,suffix:string);
function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
{  Unreliable way to get a name from a pointer to its info }


implementation

uses
  blocks,objects;

const
  semicrlf = ';'+^M+^J;


function obj_ofs(obj:pointer):word;
begin
  obj_ofs := ptr_diff(obj,buffer);
end;

function get_buffer(obj:pointer):pointer;
begin
  get_buffer := ptr(seg(obj^),0);
end;

{$IFDEF UNIT60}
procedure write_type_def(def:type_def_ptr);far;
var
  i : integer;
  l : longint;
  save_kind : byte;
  field_list : list_ptr;
  current : list_ptr;
  obj : obj_ptr;
  no_name : string;
  save_in_array : boolean;
begin
  with def^ do
  begin
    if base_type in [1,2,4,6,8,$a,$e,$f,$10,$11,$12,$13,$15,$18,$19,$1a,$1b,
                     $21,$22,$23] then
      case base_type of
        1 : write('untyped');
        2 : write('shortint');
        4 : write('integer');
        6 : write('longint');
        8 : write('byte');
       $a : write('word');
       $e : write('single');
       $f : write('double');
      $10 : write('extended');
      $11 : write('real');
      $12 : write('boolean');
      $13 : write('char');
      $15 : write('comp');
      $18 : write('text');
      $19 : write('file');
      $1a : write('pointer');
      $1b : write('string');
      { TPW types }
      $21 : write('wordbool');
      $22 : write('longbool');
      $23 : write('pchar');
    end
    else
    begin
      if base_type <> 0 then
        WriteError('{ unrecognized base type '+hexbyte(base_type)+'}');
      case type_type of
        0 : write('untyped');
        1 : begin                  {Array}
              write('array[');
              write_var_type(index_unit,index_ofs);
              write('] of ');
              write_var_type(element_unit,element_ofs);
            end;
        2 : begin                  {Record}
              save_kind := last_kind;
              last_kind := record_id;
              writeln ('Record ');

              build_list(field_list,buffer,add_only_offset(buffer,hash_ofs));

              current := field_list;
              inc(indentation,2);
              while current^.offset < $ffff do
              begin
                obj := add_only_offset(buffer,current^.offset);
                print_obj(obj);
                current := current^.next;
              end;
              dec(indentation);
              indent;
              dec(indentation);
              write('end');
              last_kind := save_kind;
            end;

        3 : begin                  {Object}
              save_kind := last_kind;
              last_kind := object_id;
              write ('Object');
              if parent_unit <> 0 then
              begin
                write('(');
                write_var_type(parent_unit,parent_ofs);
                write(')');
              end;
              write(tab,'{ vmt block ',hexword(handle));
              if w10 <> 0 then
                write(' w10=',hexword(w10));
              writeln('}');

              build_list(field_list,buffer,add_only_offset(buffer,hash_ofs));

              inc(indentation,2);
              current := field_list;
              while current^.offset < $ffff do
              begin
                obj := add_only_offset(buffer,current^.offset);
                print_obj(obj);
                current := current^.next;
              end;
              dec(indentation);
              indent;
              write('end');
              dec(indentation);
              last_kind := save_kind;
            end;

        4 : begin                  {File}
              write('file');
              if base_unit <> 0 then
              begin
                write(' of ');
                write_var_type(base_unit,base_ofs);
              end;
            end;
        5 : write('built-in text type');
        6 : begin                  {function/procedure}
              no_name := '';
              write_proc_type(no_name,[],func_type_ptr(addr(return_ofs)));
              writeln;
            end;
        7 : begin                  {Set}
              write('set of ');
              write_var_type(base_unit,base_ofs);
            end;
        8 : begin                  {Pointer}
              write('^');
              write_var_type(target_unit,target_ofs);
            end;

        9 : begin                  {String}
              write('string[',size-1,']');
              {N.B. actually record is like array of char, but "string" with
                    no length is different.}
            end;
       10 : write('built-in ',size,' byte 8087 type');    {8087}
       11 : write('built-in 6-byte real');
       12 : begin                  {Range}
              write(lower,'..',upper);
            end;
       13 : write('built-in boolean');
       14 : write('built-in char type');
       15 : begin                  {Enumeration or subrange}
              if (type_unit = unit_list[1]^.own_record)
                 and (type_ofs = obj_ofs(def)) then
              begin
                { Must be first definition }
                write('(');
                NowEnum:=type_def_ptr(Def);
                {  Assume following records are constant declarations  }
                obj := add_only_offset(def,30);
                for l:=lower to upper-1 do
                begin
                  write(obj^.name,',');
                  obj:=add_only_offset(obj,12+length(obj^.name));
                end;
                write(obj^.name,')');
              end
              else
              begin
                { Must be subrange }
                obj := add_only_offset(get_unit(type_unit)^.buffer,type_ofs);
                obj := add_only_offset(obj,24);
                i := 0;
                while i < def^.lower do
                begin
                  obj:=add_only_offset(obj,12+length(obj^.name));
                  inc(i);
                end;
                write(obj^.name);
                while i < def^.upper do
                begin
                  obj:=add_only_offset(obj,12+length(obj^.name));
                  inc(i);
                end;
                write('..',obj^.name);
              end;
            end;
       else
            begin
              WriteError('Type definition of type '+decword(type_type));
              writeln(' otherbyte=',other_byte,'size=',size);
              indent;
              write(' junk=');
              for i:=3 to 8 do
                write(who_knows[i]:6);
              writeln;
            end;
      end;
    end;
  end;
end;
{$ELSE}
procedure write_type_def(def:type_def_ptr);far;
var
  i : integer;
  l : longint;
  save_kind : byte;
  field_list : list_ptr;
  current : list_ptr;
  obj : obj_ptr;
  type_obj : type_def_ptr;
  no_name : string;
  save_in_array : boolean;
  bt:byte;
begin
  with def^ do
  begin
    if base_type in [1,2,4,6,8,$a,$e,$f,$10,$11,$12,$13,$15,$18,$19,$1a,$1b,
                     $21,$22,$23] then
    begin
      bt:=255;
      case base_type of
        1 : begin write('untyped');  bt:=0    end;
        2 : begin write('shortint'); bt:=12;  end;
        4 : begin write('integer');  bt:=12;  end;
        6 : begin write('longint');  bt:=12;  end;
        8 : begin write('byte');     bt:=12;  end;
       $a : begin write('word');     bt:=12;  end;
       $e : begin write('single');   bt:=10;  end;
       $f : begin write('double');   bt:=10;  end;
      $10 : begin write('extended'); bt:=10;  end;
      $11 : begin write('real');     bt:=11;  end;
      $12 : begin write('boolean');  bt:=13;  end;
      $13 : begin write('char');     bt:=14;  end;
      $15 : begin write('comp');     bt:=10;  end;
      $18 : begin write('text');     bt:=5;   end;
      $19 : begin write('file');     bt:=4;   end;
      $1a : begin write('pointer');  bt:=8;   end;
      $1b : begin write('string');   bt:=9;   end;
      { TPW types }
      $21 : begin write('wordbool'); bt:=13;  end;
      $22 : begin write('longbool'); bt:=13;  end;
      $23 : begin write('pchar');    bt:=8;   end;
      end;
      if type_type<>bt then
        Write('{base type <-> type_type error}');
    end
    else
    begin
      if base_type <> 0 then
        WriteError('{ unrecognized base type '+hexbyte(base_type)+'}');
      case type_type of
        0 : write('untyped');
        1 : begin                  {Array}
              write('array[');
              write_var_type(index_unit,index_ofs);
              write('] of ');
              write_var_type(element_unit,element_ofs);
            end;
        2 : begin                  {Record}
              save_kind := last_kind;
              last_kind := record_id;
              writeln ('Record ');

              build_list(field_list,buffer,add_only_offset(buffer,hash_ofs));

              current := field_list;
              inc(indentation,2);
              while current^.offset < $ffff do
              begin
                obj := add_only_offset(buffer,current^.offset);
                print_obj(obj);
                current := current^.next;
              end;
              dec(indentation);
              indent;
              dec(indentation);
              write('end');
              last_kind := save_kind;
            end;

        3 : begin                  {Object}
              save_kind := last_kind;
              last_kind := object_id;
              write ('Object');
              if parent_unit <> 0 then
              begin
                write('(');
                write_var_type(parent_unit,parent_ofs);
                write(')');
              end;
              write(tab,'{ vmt block ',hexword(handle));
              if w10 <> 0 then
                write(' w10=',hexword(w10));
              writeln('}');

              build_list(field_list,buffer,add_only_offset(buffer,hash_ofs));

              inc(indentation,2);
              current := field_list;
              while current^.offset < $ffff do
              begin
                obj := add_only_offset(buffer,current^.offset);
                print_obj(obj);
                current := current^.next;
              end;
              dec(indentation);
              indent;
              write('end');
              dec(indentation);
              last_kind := save_kind;
            end;

        4 : begin                  {File}
              write('file');
              if base_unit <> 0 then
              begin
                write(' of ');
                write_var_type(base_unit,base_ofs);
              end;
            end;
        5 : write('built-in text type');
        6 : begin                  {function/procedure}
              no_name := '';
              write_proc_type(no_name,[],func_type_ptr(addr(return_ofs)));
            end;
        7 : begin                  {Set}
              write('set of ');
              write_var_type(base_unit,base_ofs);
            end;
        8 : begin                  {Pointer}
              write('^');
              write_var_type(target_unit,target_ofs);
            end;

        9 : begin                  {String}
              write('string[',size-1,']');
              {N.B. actually record is like array of char, but "string" with
                    no length is different.}
            end;
       10 : write('built-in ',size,' byte 8087 type');    {8087}
       11 : write('built-in 6-byte real');
       12,13,14 : begin                  {Range}
              write_const_type(lower,type_unit,type_ofs,
                               get_buffer(def));
              write('..');
              write_const_type(upper,type_unit,type_ofs,
                               get_buffer(def));
            end;
       15 : begin                  {Enumeration or subrange}
              if (type_unit = unit_list[1]^.own_record)
                 and (type_ofs = obj_ofs(def)) then
              begin
                { Must be first definition }
                write('(');
                {  Assume following records are constant declarations  }
                for l:=lower to upper do
                begin
                  if l<>lower then write(',');
                  write_enum_const(def,l);
                end;
                NowEnum:=def;
                write(')');
              end
              else
              begin
                { Must be subrange }
                type_obj := add_only_offset(get_unit(type_unit)^.buffer,type_ofs);
                write_enum_const(type_obj,def^.lower);
                write('..');
                write_enum_const(type_obj,def^.upper);
              end;
            end;
       else
            begin
              WriteError('Type definition of type '+decword(type_type));
              writeln(' otherbyte=',other_byte,'size=',size);
              indent;
              write(' junk=');
              for i:=3 to 8 do
                write(who_knows[i]:6);
              writeln;
            end;
      end;
    end;
  end;
end;
{$ENDIF}

procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
var
  def_obj : obj_ptr;
begin
  indent;
  if (last_kind <> record_id) and (last_kind <> type_id) then
  begin
    writeln('type');
    indent;
    last_kind := type_id;
  end;
  write(oneindent,name,'=',oneindent);
  with info^ do
    if obj = find_type(get_unit(type_unit),type_def_ofs) then
      write_type_def(add_only_offset(buffer,type_def_ofs))
    else
      write_var_type(type_unit,type_def_ofs);
  writeln(';');
end;

function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
var
  current:list_ptr;
  obj : obj_ptr;
  obj_info : type_info_ptr;
begin
  with unit_rec^ do
  begin
    if (obj_list = nil) and (buffer <> nil) then
      build_list(obj_list,buffer,add_only_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
    if obj_list <> nil then
    begin
      current := obj_list;
      while current^.offset < $ffff do
      begin
        obj := add_only_offset(buffer,current^.offset);
        obj_info := add_only_offset(obj,4+length(obj^.name));
        if     (obj^.obj_type = type_id)
           and (obj_info^.type_def_ofs = def_ofs)
           and (obj_info^.type_unit = own_record) then
        begin
          find_type := obj;
          exit;
        end;
        current := current^.next;
      end;
    end;
    find_type := nil;
  end;
end;

function find_type_or_proc(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
var
  current:list_ptr;
  obj : obj_ptr;
  obj_info : type_info_ptr;
begin
  with unit_rec^ do
  begin
    if (obj_list = nil) and (buffer <> nil) then
      build_list(obj_list,buffer,add_only_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
    if obj_list <> nil then
    begin
      current := obj_list;
      while current^.offset < $ffff do
      begin
        obj := add_only_offset(buffer,current^.offset);
        obj_info := add_only_offset(obj,4+length(obj^.name));
        if     ((obj^.obj_type = type_id)
             and (obj_info^.type_def_ofs = def_ofs)
             and (obj_info^.type_unit = own_record))
          or
             ((obj^.obj_type = proc_id)
             and (ofs(obj^)=def_ofs))
             then
        begin
          find_type_or_proc := obj;
          exit;
        end;
        current := current^.next;
      end;
    end;
    find_type_or_proc := nil;
  end;
end;

procedure make_proc_list_entry(var in_unit:unit_list_ptr);
var
  buffer:byte_array_ptr;
  lname:string;

procedure fpe(obj_list:list_ptr;var proc_list:proc_list_ptr);
var
  current:list_ptr;
  obj : obj_ptr;
  obj_info : func_info_ptr;
  obj_list2:list_ptr;
  fp:string;
  def:type_def_ptr;
  lastlen:integer;
procedure Insert(const name:string;Entry:word);
var Aux:proc_list_ptr;
begin
  New(Aux);
  Aux^.name:=NewStr(name);
  Aux^.Entry:=Entry;
  Aux^.Next:=proc_list;
  proc_list:=aux;
end;

begin
  if obj_list <> nil then
  begin
    current := obj_list;
    while current^.offset < $ffff do
    begin
      obj := add_only_offset(buffer,current^.offset);
      obj_info := add_only_offset(obj,4+length(obj^.name));
      if (obj^.obj_type = type_id) then
      begin
        if get_unit_buffer(buffer,type_info_ptr(obj_info)^.type_unit)^.buffer=buffer then
        begin {only types defined in this unit }
          def:=add_only_offset(buffer,type_info_ptr(obj_info)^.type_def_ofs);
          if (def^.type_type=3) and (def^.hash_ofs<>0) then { object }
          begin
            build_list(obj_list2,buffer,add_only_offset(buffer,def^.hash_ofs));
            lastlen:=length(lname);
            lname:=lname+obj^.name+'.';
            fpe(obj_list2,proc_list);
            lname[0]:=char(lastlen);
            destroy_list(obj_list2);
          end;
        end
      end
      else if ((obj^.obj_type and $7f) = proc_id) then
      begin
        Insert(lname+obj^.name,obj_info^.entry_ofs);
        if (obj_info^.local_hash<>0) then
        begin
          build_list(obj_list2,buffer,add_only_offset(buffer,obj_info^.local_hash));
          lastlen:=length(lname);
          lname:=lname+obj^.name+'.';
          fpe(obj_list2,proc_list);
          lname[0]:=char(lastlen);
          destroy_list(obj_list2);
        end;
      end;
      current := current^.next;
    end;
  end;
end;

begin
  with in_unit^ do
  begin
    if (obj_list = nil) and (buffer <> nil) then
      build_list(obj_list,buffer,add_only_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
  end;
  buffer:=in_unit^.buffer;
  in_unit^.proc_list:=nil;
  lname:='';
  fpe(in_unit^.obj_list,in_unit^.proc_list);
end;

function find_proc_with_entry(in_unit:unit_list_ptr;entry:word):string;
var
  act:proc_list_ptr;
begin
  if entry=0 then
  begin
    find_proc_with_entry:='Startup code';
    exit;
  end;
  find_proc_with_entry := '';
  with in_unit^ do
  begin
    if (proc_list = nil) and (buffer <> nil) then
      make_proc_list_entry(in_unit);
  end;
  act:=in_unit^.proc_list;
  while act<>nil do
  begin
    if act^.entry=entry then
    begin
      find_proc_with_entry:=act^.name^;
      break;
    end;
    act:=act^.next;
  end;
end;


function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
{  Unreliable way to get a name from a pointer to its info }
var
  i:word;
  fname:string;
begin
  with unit_rec^ do
  begin
    if buffer <> nil then
      for i:=info_ofs-2 downto 0 do
        if i+buffer^[i]+1 = info_ofs then
        begin
          move(buffer^[i],fname[0],buffer^[i]+1);
          find_name := fname;
          exit;
        end;
  end;
  find_name := '';
end;

procedure write_var_type(type_unit,type_def_ofs:word);
var
  type_obj : obj_ptr;
  unit_ptr : unit_list_ptr;
begin
  if type_unit > 0 then
  begin
    unit_ptr := get_unit(type_unit);
    with unit_ptr^ do
    begin
      if buffer <> nil then
      begin
        type_obj := find_type(unit_ptr,type_def_ofs);
        if type_obj <> nil then
          write(type_obj^.name)
        else
          write_type_def(add_only_offset(buffer,type_def_ofs));
      end
      else
        write(name,'.ofs',type_def_ofs);
    end;
  end
  else
    WriteError('type_unit not found');
end;

procedure write_var_info(var name:string; info:var_info_ptr);
var
  orig_unit:unit_list_ptr;
  f : var_flags;
begin
  indent;
  with info^ do
  begin
    if not (last_kind in [object_id,objpriv_id,record_id]) then
    begin
      f := flags*[const_flag,local,referenced,const_arg];
      if f = [] then
        write_general(var_id,'var',name,':'+oneindent)
      else if f = [const_flag] then
        write_general(const_id,'const',name,':'+oneindent)
      else if f = [const_flag,local] then
        write_general(var_id,'var',name,':'+oneindent)
      else if f = [local] then
        write_general(local_id,'local var',name,':'+oneindent)
      else if f = [local,referenced] then
        write_general(referenced_id,'referenced var',name,':'+oneindent)
      else if f = [local,referenced,const_arg] then
        write_general(refconst_id,'referenced const',name,':'+oneindent)
      else
        WriteError(' var flags = '+hexbyte(byte(flags))+oneindent);
      end
    else
      write(name,':',oneindent);

    write_var_type(type_unit,type_def_ofs);

    if absolute in flags then
    begin
      write(' absolute ');
      orig_unit := get_unit(in_unit);
      if orig_unit <> nil then
      begin
        if orig_unit <> unit_list[1] then
          write(orig_unit^.name,'.');
        writeln(find_name(orig_unit,offset),';');
      end
      else
        WriteError('?????;');
    end
    else
    begin
      if const_flag in flags then
        if local in flags then
          write(' absolute $'+hexword(in_unit)+':$'+hexword(offset))
        else
          write('=',oneindent,'?');
      if in_function and not (const_flag in flags) then
      begin
        write(';',tab,'{BP ofs ');
        if integer(offset)<0 then
          write('-')
        else
          write('+');
        write(hexwordasm(abs(integer(offset))));
        writeln('}');
      end
      else
      begin
        write(';');
        if flags<>[const_flag,local] then
        begin
          write(tab,'{ofs ',hexwordblank(offset));
          if not (last_kind in [record_id,object_id,objpriv_id]) then
            write(' in block ',hexwordblank(in_unit));
          write('}');
        end;
        writeln;
      end;
    end;
    if v128 in flags then
      WriteError('Unknown variable flag '+HexWord(Byte(flags)));
  end;
end;

procedure write_args(arg:arg_ptr;num_args:word);
var
  i:word;
begin
  writeln('(');
  inc(indentation);
  for i:=1 to num_args do
  begin
    with arg^ do
    begin
      indent;
      if referenced in flags then
        write('var   ')
      else if const_arg in flags then
        write('const ')
      else
        write('      ');
      if flags - [referenced,const_arg] <> [local] then
      begin
        WriteError('{ flags ='+hexbyte(byte(flags))+' }');
        indent;
      end;
      write('arg',i,':',oneindent);
      write_var_type(type_unit,type_def_ofs);
      if i<>num_args then
        writeln(';')
      else
        writeln;
    end;
    arg := add_only_offset(arg,sizeof(arg_rec));
  end;
  indent;
  write(')');
  dec(indentation);
end;

procedure write_locals(var name:string; info:func_info_ptr);
var
  obj_list : list_ptr;
  save_in_function : boolean;
begin
  if info^.local_hash = 0 then
    exit;
  save_in_function := in_function;
  in_function := true;
  build_list(obj_list,buffer,add_only_offset(buffer,info^.local_hash));
  inc(indentation);
  indent; writeln('{ ',name,' locals begin...}');
  print_name_list(obj_list);
  indent; writeln('{ ...',name,' locals end.}');
  writeln;
  dec(indentation);
  in_function := save_in_function;
end;


procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
var
  proc : boolean;
begin
  with info^ do
  begin
    if (type_def_ofs = 0) and (type_unit = 0) then
      proc := true
    else
      proc := false;
    if construct in flags then
      write('constructor',oneindent,name)
    else if destruct in flags then
      write('destructor',oneindent,name)
    else
      if proc then
        write('procedure',oneindent,name)
      else
        write('function',oneindent,name);
    if info^.num_args > 0 then
      write_args(arg_ptr(add_only_offset(info,sizeof(func_type_rec))),
                 info^.num_args);
    if not proc then
    begin
      write(':',oneindent);
      write_var_type(type_unit,type_def_ofs);
    end;
  end;
  if Name<>'' then
    write(';');
end;

{$IFDEF UNIT60}
procedure write_proc_info(var name:string; info:func_info_ptr);
var
  entry_pt : entry_pt_ptr;
  code : ^word;
  i : word;
  unknown_flags : obj_flags;
begin
  indent;
  with info^ do
  begin
    write_proc_type(name,code_type,func_type_ptr(addr(func_type)));
    entry_pt := add_only_offset(buffer,header^.ofs_entry_pts+entry_ofs);

    if vmt_entry > 0 then
    begin
      write(' virtual');
      if dynamic in obj_type then
        write(' ',vmt_entry);
      write(';');
    end;

    if external_code in code_type then
      write(' external;');
    if assembler in code_type then
      write(' assembler;');
    if interrupt in code_type then
      write(' interrupt;');

    if exported in obj_type then
      write(' export;');
    if windows_frame in obj_type then
      write(' W+;');

    if from_dll in obj_type then
    begin
      write(' external ''',dll_name(entry_pt^.code_block),'''');
      if by_name in obj_type then
        write(' name ''',dll_name(entry_pt^.offset),'''')
      else
        write(' index ',entry_pt^.offset);
      write(';');
    end
    else
      if by_name in obj_type then
        write(' Unexpected by_name flag!');

    if local_code in obj_type then
      write(' local code;');

    unknown_flags := obj_type - [exported,windows_frame,from_dll,by_name,
                                  dynamic,local_code];
    if unknown_flags <> [] then
      write(' Unrecognized object flags: ',hexbyte(byte(unknown_flags)));
    if not (inline_code in code_type) then
    begin
      write(tab,'{ Proc ',hexwordblank(entry_ofs));
      if not (from_dll in obj_type) then
        write(' Entry ',hexwordblank(entry_pt^.code_block),':',
                            hexword(entry_pt^.offset));
      if (vmt_entry > 0) and not (dynamic in obj_type) then
        write(' vmt index ',hexword(vmt_entry),'h');
      writeln('}');
    end
    else
    begin
      writeln;
      indent;
      write(' Inline(');
      code := add_only_offset(info,sizeof(func_info_rec)
                             +func_type.num_args*sizeof(arg_rec));
      for i:=1 to entry_ofs div 2 - 1 do
      begin
        write('$',hexbyte(hi(code^)):2,'/');
        if lo(code^) <> 0 then
          writeln('Low byte not zero!');
        code := add_only_offset(code,sizeof(word));
      end;
      writeln('$',hexbyte(hi(code^)):2,');');
      if lo(code^) <> 0 then
        writeln('Low byte not zero!');
    end;
    if do_locals in active_options then
      write_locals(name,info);
  end;
end;
{$ELSE}

procedure write_proc_info(var name:string; info:func_info_ptr);
type
  inline_data_ptr = ^inline_data;
  inline_data = record
    itype:byte;
    case integer of
      0:(b:byte);
      1:(w:word);
      2:(offset,block,block_unit:word);
    end;
var
  entry_pt : entry_pt_ptr;
  code_ptr,codestart : inline_data_ptr;
  i : word;
  unknown_flags : obj_flags;
begin
  indent;
  with info^ do
  begin
    write_proc_type(name,code_type,func_type_ptr(addr(func_type)));
    entry_pt := add_only_offset(buffer,header^.ofs_entry_pts+entry_ofs);

    if vmt_entry > 0 then
    begin
      write(' virtual');
      if dynamic in obj_type then
        write(' ',vmt_entry);
      write(';');
    end;

    if external_code in code_type then
      write(' external;');
    if assembler in code_type then
      write(' assembler;');
    if interrupt in code_type then
      write(' interrupt;');

    if exported in obj_type then
      write(' export;');
    if windows_frame in obj_type then
      write(' W+;');

    if not (not_from_dll in obj_type) and
       ([inline_code,external_code,interrupt,assembler]*code_type=[]) then
    begin
      write(' external ''',dll_name(entry_pt^.code_block),'''');
      if ent_by_name in entry_pt^.flags then
        write(' name ''',dll_name(entry_pt^.offset),'''')
      else
        write(' index ',entry_pt^.offset);
      write(';');
    end;

    unknown_flags := obj_type - [exported,windows_frame,not_from_dll,
                                  dynamic];
    if unknown_flags <> [] then
      WriteError(' Unrecognized object flags: '+hexbyte(byte(unknown_flags)));
    if not (inline_code in code_type) then
    begin
      write(tab,'{ Proc ',hexwordblank(entry_ofs));
      if not_from_dll in obj_type then
        write(' Entry ',hexwordblank(entry_pt^.code_block),':',
                            hexword(entry_pt^.offset));
      if (vmt_entry > 0) and not (dynamic in obj_type) then
        write(' vmt index ',hexword(vmt_entry),'h');
      writeln('}');
    end
    else
    begin
      writeln;
      indent;
      write(' Inline(');
      codestart := add_only_offset(info,sizeof(func_info_rec)
                             +func_type.num_args*sizeof(arg_rec));
      i:=0;
      while i<entry_ofs do
      begin
        code_ptr := add_only_offset(codestart,i);
        case code_ptr^.itype of
        0 : begin
              write('<$',hexbyte(code_ptr^.b):2);
              Inc(i,2);
            end;
        1 : begin
              write('>$',hexword(code_ptr^.w):4);
              Inc(i,3);
            end;
        2,3 : begin
              write('{ofs ',hexwordblank(code_ptr^.offset),' in ');
              if code_ptr^.itype=2 then
                write('var')
              else
                write('const');
              write(' block ',hexwordblank(code_ptr^.block));
              write(' in unit ',get_unit_name(code_ptr^.block_unit));
              writeln('}');
              write('':10);
              Inc(i,7);
            end;
        else
          WriteError('Inline code unknown type!');
          Inc(i,1);
        end;
        if i=entry_ofs then
          writeln(');')
        else
          write('/');
      end;
    end;
    if (next_method<>0) and not (method in code_type) then
      WriteError('Unknown next_method value');
    if (w4<>$0d06) then
      WriteError('Unknown w4 value');
    if not (((w5=4) and not (method in code_type)) or
            ((w5=8) and (method in code_type))) then
      WriteError('Unknown w5 value');
    if (w6<>0) then
      WriteError('Unknown w6 value');
    if do_locals in active_options then
      write_locals(name,info);
  end;
end;
{$ENDIF}

procedure write_enum_const(type_obj:type_def_ptr;val:longint);
var obj : obj_ptr;
    i : integer;
begin
  if type_obj^.type_type<>15 then
  begin
    WriteError('Not enum const!?');
    exit;
  end;
  obj := add_only_offset(type_obj,32);
  i := 0;
  while i < val do
  begin
    obj:=add_only_offset(obj,12+length(obj^.name));
    inc(i);
  end;
  write(obj^.name);
end;

procedure write_const_type(var Val;type_unit,type_def_ofs:word;buffer:pointer);
var type_obj:type_def_ptr;
    last,l:longint;
    count,i,state:Integer;
    range:boolean;
    unit_ptr:unit_list_ptr;
begin
  if buffer<>nil then
    unit_ptr:=get_unit_buffer(buffer,type_unit)
  else
    unit_ptr:=get_unit(type_unit);
  with  unit_ptr^ do
  begin
    if buffer<>nil then
    begin
      type_obj:=add_only_offset(buffer,type_def_ofs);
      case type_obj^.type_type of
      9   { string }
         : begin
             state:=0;
             for i:=1 to length(string(val)) do
             begin
               if string(val)[i]<' ' then
                 case state of
                 0: begin
                     state:=2;
                     write('#$',hexbyte(ord(string(val)[i])));
                    end;
                 1: begin
                      write('''#$',hexbyte(ord(string(val)[i])));
                      state:=2;
                    end;
                 2: write('#$',hexbyte(ord(string(val)[i])));
                 end
               else
                 case state of
                 0,2: begin
                     state:=1;
                     write('''',string(val)[i]);
                    end;
                 1: write(string(val)[i]);
                 end;
             end;
           if state=1 then
             write('''');
           end;
      15  { enum }
         : begin
             if NowEnum=nil then
               write_enum_const(type_obj,longint(val))
             else
               write(integer(val));
           end;
      12  { int }
         : write(longint(val));
      13  { bool }
         : write(boolean(val));
      14  { char }
         : if (char(val)<' ') or (char(val)>#$fe) then
             write('#$',hexbyte(byte(val)))
           else
             write('''',char(val),'''');
      10  { extend }
         : write(extended(val));
      8   { pointer }
         : write('ptr($'+hexword(seg(pointer(val)^))+
                 ',$'+hexword(ofs(pointer(val)^))+')');
      7   { set }
         : begin
             write('[');
             Count:=0;
             last:=-2;
             Range:=False;
             for l:=0 to 255 do
               if l in tbyteset(val) then
               begin
                 if Range or (last=l-1) then
                   Range:=True
                 else
                 begin
                   inc(Count);
                   if Count>1 then
                     write(',');
                   write_const_type(l,type_obj^.base_unit,type_obj^.base_ofs,buffer);
                   last:=l;
                 end
               end
               else
               begin
                 if Range then
                 begin
                   Range:=False;
                   if last=l-2 then
                   begin
                     last:=l-1;
                     write(',');
                     write_const_type(last,type_obj^.base_unit,type_obj^.base_ofs,buffer);
                   end
                   else
                   begin
                     last:=l-1;
                     write('..');
                     write_const_type(last,type_obj^.base_unit,type_obj^.base_ofs,buffer);
                   end;
                 end;
                 last:=-2;
               end;
             write(']');
           end;
      else
        WriteError('Unknown type of constant');
      end;
    end
    else
      Write('?');
  end;
end;

procedure write_const_info(var name:string; info:const_info_ptr);
var
  type_obj : type_def_ptr;
begin
  indent;
  if (NowEnum<>nil) and ((info^.type_def_ofs<>Ofs(NowEnum^)) or
     (Seg(get_unit(info^.type_unit)^.buffer^)<>Seg(NowEnum^))) then
  begin
    Writeln('*)');
    NowEnum:=nil;
    last_kind:=init_id;
  end;
  if (last_kind <> record_id) and (last_kind <> const_id) then
  begin
    if NowEnum<>nil then
      Write('(* ');
    writeln('Const');
    indent;
    last_kind := const_id;
  end;
  write(oneindent,name,'=',oneindent);
  write_const_type(info^.allval,info^.type_unit,info^.type_def_ofs,nil);
  writeln(';');
end;

procedure write_unit_info(var name:string; info:unit_ptr; self:boolean);
begin
  indent;
  if self then
  begin
    write('Unit',oneindent,name,';');
    last_kind := init_id;
  end
  else
  begin
    if last_kind = unit_id then
    begin
      writeln;
      write(oneindent,',',name);
    end
    else
    begin
      write('Uses',oneindent,name);
      last_kind := unit_id;
    end;
  end;
  with info^ do
  begin
    write(tab,'{ checksum = ',hexword(checksum),'}');
    if self then
    begin
      writeln;
      writeln('interface');
    end;
  end;
end;

procedure write_system_type(var name:string; kind:byte; info:system_info_ptr);
begin
  if kind=sys_proc_id then
    write('procedure')
  else if kind=sys_fn_id  then
    write('function');

  with info^ do
  begin
    write(oneindent,name,tab,'{ Special index ',hexbyte(addr_ofs));
    if flags <> 0 then
      write(oneindent,'Flags ',hexbyte(flags));  { What are those flags!!??! }
    writeln(' }');
  end;
  last_kind := kind;
end;

procedure write_general(kind:byte; title,name,suffix:string);
begin
  if last_kind <> kind then
  begin
    writeln(title);
    last_kind := kind;
    indent;
  end;
  write(oneindent,name,suffix);
end;

procedure print_obj(obj:obj_ptr);
var
  j:word;
  obj_info : ^byte_array;
  new_entry : list_ptr;
  info_len,info_ofs : word;
  obj_type : byte;
const
  dump_types  : set of byte = [];
begin
  info_ofs := sizeof(obj_rec)-sizeof(string)+1+length(obj^.name);
  obj_info := add_only_offset(obj,info_ofs);
  obj_type := obj^.obj_type;
  if (obj_type and $80) <> 0 then
  begin
    if last_kind <> objpriv_id then
    begin
      dec(indentation);
      indent;
      inc(indentation);
      writeln('private');
      last_kind := objpriv_id;
    end;
    obj_type := obj_type and $7F;
  end;

  if obj_type in known_types then
  begin
    if last_kind<>obj_type then
    begin
      if (obj_type<>const_id) and (NowEnum<>nil) then
      begin
        if last_kind=const_id then
          Writeln('*)');
        NowEnum:=nil;
      end;
      if last_kind=unit_id then
        writeln(';');
    end;
    if obj_type=const_id then
    begin
      write_const_info(obj^.name,pointer(obj_info));
    end
    else if obj_type=type_id then
    begin
      write_type_info(obj^.name,obj,pointer(obj_info));
    end
    else if obj_type=var_id then
    begin
      write_var_info(obj^.name,pointer(obj_info));
    end
    else if obj_type=proc_id then
    begin
      write_proc_info(obj^.name,pointer(obj_info));
      if not (last_kind in [object_id,objpriv_id]) then
        last_kind := proc_id;
    end
    else if (obj_type=sys_proc_id) or (obj_type=sys_fn_id) then
    begin
      write_system_type(obj^.name,obj_type,pointer(obj_info));
    end
    else if obj_type=sys_port_id then
    begin
      write_general(sys_port_id,'type {port array}',obj^.name,':'+oneindent);
      if byte_array_ptr(obj_info)^[0]=0 then
        writeln('Byte;')
      else
        writeln('Word;')
    end
    else if obj_type=sys_mem_id then
    begin
      write_general(sys_mem_id,'type {memory array}',obj^.name,':'+oneindent);
      write_type_def(add_only_offset(buffer,type_info_ptr(obj_info)^.type_def_ofs));
      writeln(';');
    end
    else if obj_type=sys_new_id then
    begin
      write_general(sys_new_id,'system allocator '+obj^.name+';','',#13#10);
    end
{$IFNDEF UNIT60}
    else if obj_type=sys_openstr_id then
    begin
      write_general(sys_openstr_id,'system open string type:'+obj^.name+';','',#13#10);
    end
{$ENDIF}
    else if obj_type=unit_id then
    begin
      write_unit_info(obj^.name,pointer(obj_info),
                     obj_ofs(obj) = header^.ofs_this_unit)
    end;
  end
  else
  begin
    WriteError('Unknown kind '+DecWord(obj_type)+oneindent+obj^.name+
               ' with info at '+hexword(obj_ofs(obj_info)));
    last_kind := obj_type;
  end;
  if obj_type in dump_types then
  begin
    for j:=0 to 15 do
      write(hexword(obj_ofs(obj_info)+j):5);
    for j:=0 to 15 do
      write(hexbyte(obj_info^[j]):5);
    for j:=16 to 31 do
      write(hexword(obj_ofs(obj_info)+j):5);
    for j:=16 to 31 do
      write(hexbyte(obj_info^[j]):5);
  end;
end;

procedure print_name_list(obj_list:list_ptr);
var
  obj : obj_ptr;
  current : list_ptr;
  bytes : ^byte_array;
  j : integer;
begin
  last_kind := init_id;
  current := obj_list;
  while current^.offset < $ffff do
  begin
    obj := add_only_offset(buffer,current^.offset);
    print_obj(obj);
    current := current^.next;
  end;
end;

end.